﻿
Partial Class Article_Gather
    Inherits System.Web.UI.Page
    Dim CArray(20, 3)
    Public Shared Function MD5(ByVal strSource As String, ByVal Code As Int16) As String
        '这里用的是ascii编码密码原文，如果要用汉字做密码，可以用UnicodeEncoding，但会与ASP中的MD5函数不兼容 
        Dim dataToHash As Byte() = (New System.Text.ASCIIEncoding).GetBytes(strSource)
        Dim hashvalue As Byte() = CType(System.Security.Cryptography.CryptoConfig.CreateFromName("MD5"), System.Security.Cryptography.HashAlgorithm).ComputeHash(dataToHash)
        Dim i As Integer
        Select Case Code
            Case 16 '´选择16位字符的加密结果 
                For i = 4 To 11
                    MD5 += Hex(hashvalue(i)).ToLower
                Next
            Case 32 ' ´选择32位字符的加密结果 
                For i = 0 To 15
                    MD5 += Hex(hashvalue(i)).ToLower
                Next
            Case Else ' ´Code错误时，返回全部字符串，即32位字符 
                For i = 0 To hashvalue.Length - 1
                    MD5 += Hex(hashvalue(i)).ToLower
                Next

        End Select
    End Function
    Function EncodeBase64(ByVal StrA)
        Dim BufferA As Byte()
        BufferA = System.Text.Encoding.Default.GetBytes(StrA)
        Dim StrB As String
        StrB = Convert.ToBase64String(BufferA)
        EncodeBase64 = StrB
    End Function
    Function DecodeBase64(ByVal StrA)
        DecodeBase64 = Encoding.GetEncoding("gb2312").GetString(Convert.FromBase64String(StrA))
    End Function
    Function PassPortCheck()
        Dim connstr, connA, rsA
        connstr = ConfigurationSettings.AppSettings("SQLConnString") & """" & Server.MapPath(".") & "\..\" & ConfigurationSettings.AppSettings("dbPath") & """"
        connA = Server.CreateObject("ADODB.Connection")
        connA.open(connstr)

        Dim Admin_UserName, Admin_UserPass
        Admin_UserName = Replace(Request.Cookies("TaoddAdmin").Value, "'", "''")
        Admin_UserPass = Replace(Request.Cookies("TaoddPassWord").Value, "'", "''")
        rsA = Server.CreateObject("adodb.recordset")
        rsA.open("select * from [admin^] where Admin_UserName='" & Admin_UserName & "' and Admin_UserPass='" & Admin_UserPass & "'", connA, 1, 3)
        If rsA.eof Then
            Response.Redirect("login.aspx")
        End If
        connA.close()
        connA = Nothing
    End Function
    Function getstr(ByVal iRemote)
        On Error Resume Next
        Dim xPost, sGet
        iRemote = iRemote
        xPost = Server.CreateObject("msxml2.serverxmlhttp") 'msxml2.serverxmlhttp
        xPost.Open("GET", iRemote, False)
        xPost.setrequestheader("referer", "http://taoke.alimama.com/spreader/search_auction.htm")
        xPost.Send()
        sGet = CreateObject("ADODB.Stream")
        sGet.Mode = 3
        sGet.Type = 1
        sGet.Open()
        On Error Resume Next

        sGet.Write(xPost.responseBody)
        sGet.Position = 0
        sGet.Type = 2
        sGet.Charset = "gb2312" ' "gb2312"
        getstr = sGet.ReadText
    End Function


    Public Shared Function MD5x(ByVal strSource As String, ByVal Code As Int16) As String
        '这里用的是ascii编码密码原文，如果要用汉字做密码，可以用UnicodeEncoding，但会与ASP中的MD5函数不兼容 
        Select Case Code
            Case 16 '´选择16位字符的加密结果 
                MD5x = System.Web.Security.FormsAuthentication.HashPasswordForStoringInConfigFile(strSource, "MD5").ToLower().Substring(8, 16)
            Case 32 ' ´选择32位字符的加密结果 
                MD5x = System.Web.Security.FormsAuthentication.HashPasswordForStoringInConfigFile(strSource, "MD5").ToLower()
        End Select
    End Function
    Function getText(ByVal tmp, ByVal s, ByVal e)
        'On Error Resume Next
        Dim String1, String2, arrstr, j
        String1 = s
        String2 = e
        Dim fbegin
        Dim fend
        fbegin = 1
        fend = 1
        Do
            fbegin = InStr(fbegin, tmp, String1)
            If fbegin = 0 Then Exit Function
            fend = InStr(fbegin, tmp, String2)
            arrstr = Mid(tmp, fbegin + Len(String1), fend - (fbegin + Len(String1)))
            getText = arrstr
            fbegin = fend + Len(String2)
        Loop While True
    End Function
    Function gethtml(ByVal tmp, ByVal s, ByVal e, ByVal id)
        'On Error Resume Next
        Dim String1, String2, arrstr, j
        String1 = s
        String2 = e
        Dim fbegin
        Dim fend
        fbegin = 1
        fend = 1
        j = 0
        Do
            fbegin = InStr(fbegin, tmp, String1)
            If fbegin = 0 Then Exit Function
            fend = InStr(fbegin, tmp, String2)
            arrstr = Mid(tmp, fbegin + Len(String1), fend - (fbegin + Len(String1)))
            If id <> -1 Then
                CArray(j, id) = arrstr
                j = j + 1
            End If
            gethtml = gethtml & arrstr & "||"
            If id = -1 Then Exit Function
            fbegin = fend + Len(String2)
        Loop While True
    End Function
    Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
        If Request.Cookies("TaoddAdmin") Is Nothing Or Request.Cookies("TaoddPassWord") Is Nothing Then
            Response.Redirect("login.aspx")
        Else
            PassPortCheck()
        End If

        If Request.QueryString("Action") = "Gether" Then
            Gether(Request.QueryString("keyword"), Request.QueryString("page"), Request.QueryString("ClassID"))
        End If
        If Request.QueryString("Action") = "GetBaiduKeyWord" Then
            Response.Write(GetBaiduCode(Request.QueryString("keyword")))
            Response.End()
        End If
    End Sub
    Function GetBaiduCode(ByVal Key)
        Dim BaiDuUrl
        BaiDuUrl = "http://www.baidu.com/s?wd=" & server.URLEncode(key)
        GetBaiduCode = getstr(BaiDuUrl)

        GetBaiduCode = Right(GetBaiduCode, Len(GetBaiduCode) - InStr(GetBaiduCode, ">相关搜索</th>") - 21)
        GetBaiduCode = Left(GetBaiduCode, InStr(GetBaiduCode, "</table></div>") - 1)
        GetBaiduCode = GetBaiduLongTail(GetBaiduCode)
        If Right(GetBaiduCode, 1) = "," Then GetBaiduCode = Left(GetBaiduCode, Len(GetBaiduCode) - 1)
    End Function
    Function GetBaiduLongTail(ByVal Code)
        On Error Resume Next
        Dim String1, String2, arrstr
        String1 = """>"
        String2 = "</a>"
        GetBaiduLongTail = ""
        Dim fbegin
        Dim fend
        fbegin = 1
        fend = 1
        Do
            fbegin = InStr(fbegin, Code, String1)
            If fbegin = 0 Or Err.Number <> 0 Then Exit Function
            fend = InStr(fbegin, Code, String2)
            arrstr = Mid(Code, fbegin + Len(String1), fend - (fbegin + Len(String1)))
            GetBaiduLongTail = GetBaiduLongTail & arrstr & ","
            fbegin = fend + Len(String2)
        Loop While True
    End Function
    Function GetSize(ByVal filename)
        Dim fso, filepath, file, b, f, fsize, f_size
        fso = server.createobject("scripting.filesystemobject")
        filepath = Server.MapPath(filename)
        If Not fso.FileExists(filepath) Then
            GetSize = 0
            fso = Nothing
            Exit Function
        End If
        f = fso.getfile(filepath)
        fsize = f.size
        GetSize = fsize
        Exit Function
        If fsize > 1048576 Then
            f_size = left((fsize / 1024) / 1024, 4) & "MB"
        ElseIf fsize > 1024 Then
            f_size = left(fsize / 1024, 4) & "KB"
        Else
            f_size = fsize
        End If
        GetSize = fsize
    End Function
    Function FileIsExist(ByVal path)
        Dim FSO
        path = Server.MapPath(path)
        FileIsExist = False
        FSO = Server.CreateObject("Scripting.FileSystemObject")
        If FSO.FileExists(path) Then
            FileIsExist = True
            FSO = Nothing
            Exit Function
        End If
    End Function
    Function CopyFiles(ByVal TempSource, ByVal TempEnd)
        Dim FSO
        CopyFiles = 0
        TempSource = Server.MapPath(TempSource)
        TempEnd = Server.MapPath(TempEnd)
        FSO = Server.CreateObject("Scripting.FileSystemObject")
        If FSO.FileExists(TempEnd) Then
            CopyFiles = 2
            FSO = Nothing
            Exit Function
        End If
        If Not FSO.FileExists(TempSource) Then

            FSO = Nothing
            Exit Function
        End If
        FSO.CopyFile(TempSource, TempEnd)
        CopyFiles = 1
        FSO = Nothing
    End Function

    Function WriteFile(ByVal f, ByVal Txt)
        Dim Fso, ts
        On Error Resume Next
        Fso = Server.CreateObject("Scripting.FileSystemObject")
        ts = Fso.createtextfile(Server.MapPath(f), True)
        ts.write(Txt)
        ts.close()
    End Function

    Function Gether(ByVal keyword, ByVal page, ByVal ClassID)
        ' On Error Resume Next
        Dim connstr, connA, connB, rsA, rsB, ArticleID, all, alltitle, need, total_num, items_num, ArticleDbFileName, dbpath, dbFilepath, ThisFileSize, CopgFileFlag, FileFlag, NewDbFileName
        Dim source
        source = Request.QueryString("source")

        connB = Server.CreateObject("ADODB.Connection")
        connB.open(ConfigurationSettings.AppSettings("SQLConnString") & """" & Server.MapPath(".") & "\..\" & ConfigurationSettings.AppSettings("dbPath") & """")
        rsA = Server.CreateObject("adodb.recordset")
        rsB = Server.CreateObject("adodb.recordset")

        rsB.open("select *  from Config", connB, 1, 3)
        ArticleDbFileName = rsB("ArticleDbFileName").value

        dbpath = ConfigurationSettings.AppSettings("dbPath")
        dbpath = Left(dbpath, InStr(dbpath, "/"))
        dbFilepath = dbpath & ArticleDbFileName
        FileFlag = 0
        If IsDBNull(rsB("ArticleDbFileName").value) Then
            FileFlag = 1
            ArticleDbFileName = ""
        Else
            If rsB("ArticleDbFileName").value = "" Then
                FileFlag = 1
            Else
                ThisFileSize = GetSize("../" & dbFilepath)
                If Int(ThisFileSize) > 20000000 Or Not FileIsExist("../" & dbFilepath) Then
                    FileFlag = 1
                End If
            End If

        End If
        If FileFlag = 1 Then
            Randomize()
            NewDbFileName = "Article_" & (Rnd() * 100000) & ".mdb"
            CopgFileFlag = CopyFiles("Article_Empty.mdb", "../" & dbpath & NewDbFileName)
            If CopgFileFlag = 1 Then
                ArticleDbFileName = NewDbFileName
                rsB("ArticleDbFileName").value = ArticleDbFileName
                rsB.update()
                dbFilepath = dbpath & ArticleDbFileName
            End If
        End If
        rsB.close()
        If ArticleDbFileName = "" Then
            Response.Write("Error|NoExistDbFile")
            Response.End()
        Else
            If Not FileIsExist("../" & dbFilepath) Then
                Response.Write("Error|NoExistDbFile")
                Response.End()
            End If
        End If
        dbFilepath = dbpath & ArticleDbFileName
        connstr = ConfigurationSettings.AppSettings("SQLConnString") & """" & Server.MapPath(".") & "\..\" & dbFilepath & """"
        connA = Server.CreateObject("ADODB.Connection")
        connA.open(connstr)
        Dim url, code, a, i
        If page = "" Then page = "1"

        url = "http://blog.soso.com/qz.q?w=site%3A163.com%20" & Server.UrlEncode(keyword) & "&sc=qz&ty=blog&sd=0&st=r&cid=&op=blog.blog&pid=qz.s.res&pg=" & page
        If source = "1" Then
            url = "http://blog.soso.com/qz.q?w=site%3A163.com%20" & Server.UrlEncode(keyword) & "&sc=qz&ty=blog&sd=0&st=r&cid=&op=blog.blog&pid=qz.s.res&pg=" & page
        End If
        If source = "2" Then
            url = "http://blog.soso.com/qz.q?w=site%3Asina.com.cn%20" & Server.UrlEncode(keyword) & "&sc=qz&ty=blog&sd=0&st=r&cid=&op=blog.blog&pid=qz.s.res&pg=" & page
        End If
        If source = "3" Then
            url = "http://blog.soso.com/qz.q?w=site%3Ahi.baidu.com%20" & Server.UrlEncode(keyword) & "&sc=qz&ty=blog&sd=0&st=r&cid=&op=blog.blog&pid=qz.s.res&pg=" & page
        End If
        If source = "4" Then
            url = "http://blog.soso.com/qz.q?w=site%3Asohu.com%20" & Server.UrlEncode(keyword) & "&sc=qz&ty=blog&sd=0&st=r&cid=&op=blog.blog&pid=qz.s.res&pg=" & page
        End If
        If source = "5" Then
            url = "http://blog.soso.com/qz.q?w=site%3Ablogbus.com%20" & Server.UrlEncode(keyword) & "&sc=qz&ty=blog&sd=0&st=r&cid=&op=blog.blog&pid=qz.s.res&pg=" & page
        End If

        code = getstr(url)
  

        a = gethtml(code, "')"" target=""_blank"">", "</a>", 0)  '标题

        a = gethtml(code, "<h3><a href=""", """ onclick=", 1)  '链接
       
        a = gethtml(code, "- <a href=""", """ class=""gr""", 2)  '快照链接

        total_num = getText(code, "var total_num = ", ";")
        items_num = getText(code, "var items_num = ", ";")
        If total_num <> "" Then
            If Int(page) * 10 > total_num Then
                Response.Write("GatherOk|<<<>" & "end" & "|<<<>" & Request.QueryString("id") & "|<<<>" & "")
                connA.close()
                connB.close()
                Response.End()
            End If
        End If

        'code=getText(code
        all = 0
        alltitle = ""
        need = Request.QueryString("need")
        If Request.QueryString("need") = "" Then
            need = 100
        Else
            need = Int(need)
        End If
        Dim CheckLen, CheckMinLen, CheckLenOk
        CheckLen = False
        CheckMinLen = 0
        If Request.QueryString("checkboxMinLen") = "true" Then
            If IsNumeric(Request.QueryString("MinLen")) Then
                CheckMinLen = Request.QueryString("MinLen")
                If CheckMinLen <> 0 Then
                    CheckLen = True
                End If
            End If
        End If
        
        For i = 0 To 20
            If CArray(i, 1) <> "" And all < need Then
                CheckLenOk = True
                CArray(i, 0) = Replace(CArray(i, 0), "<em>", "")
                CArray(i, 0) = Replace(CArray(i, 0), "</em>", "")
                'Response.Write(CArray(i, 1) & "</br>")
                ArticleID = MD5x(CArray(i, 1), 32)

                rsA.open("select * from [Article] where ArticleID='" & ArticleID & "'", connB, 1, 3)
                If rsA.eof Then
                    url = "http://blog.soso.com" & CArray(i, 2)

                    code = getstr(url)
                    If InStr(code, "- 博文预览</title>") Then CArray(i, 0) = Trim(getText(code, "<title>", "- 博文预览</title>"))
                    code = getText(code, "<div id=""main"">", "<br/>" & vbNewLine & "<br/>")
                    code = Right(code, Len(code) - InStr(code, "<br /><br />") - 11)
                    If code <> "" Then


                        code = Replace(code, "<em>", "")
                        code = Replace(code, "</em>", "")
                        code = Replace(code, vbNewLine, "")
                        code = Replace(code, "很抱歉，因为您在网易相册发布了违规信息，账号被屏蔽。被屏蔽期间他人无法访问您的相册。 <br /><br />　　去帮助中心，了解如何重新恢复服务。", "")
                        If InStr(code, "http://b.bst.126.net/style/common/tuijian.png") Then
                            code = Replace(code, "<img src=""http://b.bst.126.net/style/common/tuijian.png"" onClick=""window.open('http://b.bst.126.net/style/common/tuijian.png')"" onerror=""this.src='http://cache.soso.com/img/blog/p1.gif'"" onload=""addjustimg(this)""  TYPE=""audio/mpeg"">", "")
                        End If
                        code = Trim(code)
                        If CheckLen Then
                            If Len(code) < CheckMinLen Then
                                CheckLenOk = False
                            End If
                        End If
                        If CheckLenOk Then


                            If Request.QueryString("AutoSplit") = "true" Then
                                On Error Resume Next
                                Dim Curlen, maxlen, k
                                If Len(code) > 2000 Then

                                    Curlen = 0
                                    maxlen = 1500
                                    For k = 1 To Int(Len(code) / maxlen)

                                        Curlen = InStr(maxlen + Curlen, code, "<br") - 1
                                        If Curlen <> 0 Then
                                            If (k = Int(Len(code) / maxlen) And Len(Right(code, Curlen)) > 600) Or (k < Int(Len(code) / maxlen)) Then
                                                If Err.Number <> 0 Then

                                                End If
                                                code = Left(code, Curlen) & "[NextPage]" & Right(code, Len(code) - Curlen)
                                            End If
                                        End If
                                    Next
                                End If
                            End If

                            rsA.addnew()
                            rsA("Title") = CArray(i, 0)
                            rsA("ClassID") = ClassID
                            rsA("ArticleID") = ArticleID
                            rsA("Intro") = Replace(Left(delHtml(code), 80), " ", "")
                            rsA("Content") = "Call|" & ArticleDbFileName
                            rsA("ActLink") = 0
                            rsA("KeyWords") = 0
                            rsA("isAccept") = 0
                            rsA("UpdateTime") = Now
                            If Request.QueryString("Publish") <> "true" Then
                                rsA("IStop") = 1
                            End If

                            rsA.update()



                            rsB.open("select * from [Article] where ArticleID='" & ArticleID & "'", connA, 1, 3)
                            rsB.addnew()
                            rsB("ArticleID") = ArticleID
                            'rsA("Intro") = Left(delHtml(code), 45)
                            rsB("Content") = code
                            rsB("UpdateTime") = Now
                            rsB.update()
                            rsB.close()
                            all = all + 1
                            alltitle = alltitle & CArray(i, 0) & "|*_*)???^"

                        End If

                    End If

                End If
                rsA.close()
            End If
        Next
        Response.Write("GatherOk|<<<>" & all & "|<<<>" & Request.QueryString("id") & "|<<<>" & alltitle)
        connA.close()
        connB.close()
        Response.End()
    End Function
    Function delHtml(ByVal strHtml) '删除HTML格式
        Dim re
        re = New Regex("<.+?>", RegexOptions.IgnoreCase)
        delHtml = re.Replace(strHtml, "")
        re = Nothing
    End Function
End Class
